====================================分段====================================== 第二种情况：先删除不重记录行，然后保留一行重复的，代码如下：

Private Sub CommandButton1_Click()

Dim 提示信息 Dim 最后行号 Dim 循环计数 Dim 重复数 Dim 筛选列 Dim 升降序

'根据需要设定筛选列 筛选列 = "B"

'禁止屏幕刷新 Application.ScreenUpdating = False

提示信息 = MsgBox("先删除不重复的行吗？", vbOKCancel, "警告：")

If 提示信息 = 1 Then '先删除不重复的 最后行号 = Range(筛选列 & "65536").End(xlUp).Row For 循环计数 = 最后行号 To 2 Step -1 '不处理首行的标题栏 重复数 = Application.WorksheetFunction.CountIf(Range(筛选列 & ":" & 筛选列), Range(筛选列 & Format(循环计数))) 'vba中调用Excel内置函数CountIf() If 重复数 = 1 Then Rows(Format(循环计数) & ":" & Format(循环计数)).Delete End If Next 循环计数 End If

'再删除重复的(保留1行) 提示信息 = MsgBox("现在删除重复数据只保留1行吗？", vbOKCancel, "警告：")

If 提示信息 = 1 Then 最后行号 = Range(筛选列 & "65536").End(xlUp).Row For 循环计数 = 最后行号 To 2 Step -1 '不处理首行的标题栏 重复数 = Application.WorksheetFunction.CountIf(Range(筛选列 & ":" & 筛选列), Range(筛选列 & Format(循环计数))) 'vba中调用Excel内置函数CountIf() 盈搜财税 www.ringsou.com If 重复数 > 1 Then Rows(Format(循环计数) & ":" & Format(循环计数)).Delete End If Next 循环计数 End If

'恢复屏幕刷新 Application.ScreenUpdating = True

'将结果排序(去掉下面的注析就可用) '最后行号 = Range(筛选列 & "65536").End(xlUp).Row '升降序 = xlAscending '升序：升降序 = xlAscending 降序：升降序 = xlDescending 'On Error Resume Next 'Range(筛选列 & 最后行号).Sort Key1:=Range(筛选列 & "2"), Order1:=升降序, Header:=xlGuess, _ 'OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _ ':=xlPinYin 'If Err 0 Then MsgBox "“" & 筛选列 & "”列无法排序！" End Sub

====================================分段====================================== 第三种情况：删除所有重复的记录1行都不要留，保留不重复的记录，代码如下：

Sub 删除重复数据() '删除col列的重复数据 '本例是删除标题为sheet1的EXCEL表中A列（从A2单元格开始）的重复数据 Application.ScreenUpdating = False '可根据实际情况修改下面三行的结尾值 Dim sheetsCaption As String: sheetsCaption = "Sheet1" Dim Col As String: Col = "A" Dim StartRow As Integer: StartRow = 1 '以下不需要修改 Dim EndRow As Integer: EndRow = Sheets(sheetsCaption).Range(Col & "65536").End(xlUp).Row Dim Count_1 As Integer: Count_1 = 0 Dim j As Integer: j = 0 Dim i As Integer: i = StartRow With Sheets(sheetsCaption) Do j = i + 1 Count_1 = 0 Do If .Range(Col & i) = .Range(Col & j) Then Count_1 = 1 .Range(Col & j).EntireRow.Delete j = j - 1 EndRow = Sheets(sheetsCaption).Range(Col & "65536").End(xlUp).Row End If j = j + 1 Loop While j < EndRow + 1

If Count_1 = 1 Then .Range(Col & i).EntireRow.Delete EndRow = Sheets(sheetsCaption).Range(Col & "65536").End(xlUp).Row i = i - 1 End If i = i + 1 Loop While i < EndRow End With MsgBox "删除成功!" Application.ScreenUpdating = True End Sub